home *** CD-ROM | disk | FTP | other *** search
/ Freelog 22 / freelog 22.iso / Prog / Djgpp / GPC2952B.ZIP / lib / gcc-lib / djgpp / 2.952 / units / md5.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-02-08  |  13.6 KB  |  399 lines
  1. {
  2. Functions to compute MD5 message digest of files or memory blocks,
  3. according to the definition of MD5 in RFC 1321 from April 1992.
  4.  
  5. IMPORTANT NOTE: This unit is distributed under the GNU GPL, NOT
  6. under the GNU LGPL under which most of the other GPC units are
  7. distributed. This means that you must distribute any code that
  8. uses this unit under the GPL as well, which means that you have to
  9. make the source code available whenever you distribute a binary of
  10. the code, and that you must allow recipients to modify the code
  11. and redistribute it under the GPL.
  12.  
  13. Copyright (C) 1995, 1996, 2000-2001 Free Software Foundation, Inc.
  14.  
  15. Based on the C code written by Ulrich Drepper
  16. <drepper@gnu.ai.mit.edu>, 1995 as part of the GNU C Library.
  17.  
  18. This file is part of GNU Pascal.
  19.  
  20. GNU Pascal is free software; you can redistribute it and/or modify
  21. it under the terms of the GNU General Public License as published by
  22. the Free Software Foundation; either version 2, or (at your option)
  23. any later version.
  24.  
  25. GNU Pascal is distributed in the hope that it will be useful,
  26. but WITHOUT ANY WARRANTY; without even the implied warranty of
  27. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  28. GNU General Public License for more details.
  29.  
  30. You should have received a copy of the GNU General Public License
  31. along with GNU Pascal; see the file COPYING. If not, write to the
  32. Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  33. 02111-1307, USA.
  34. }
  35.  
  36. {$gnu-pascal,B-,I-}
  37. {$if __GPC_RELEASE__ < 20000412}
  38. {$error This unit requires GPC release 20000412 or newer.}
  39. {$endif}
  40.  
  41. unit MD5;
  42.  
  43. interface
  44.  
  45. uses GPC;
  46.  
  47. { Representation of a MD5 value. It is always in little endian byte
  48.   order and therefore portable. }
  49. type
  50.   Card8 = Cardinal (8);
  51.   TMD5 = array [1 .. 16] of Card8;
  52.  
  53. { Computes MD5 message digest for Length bytes in Buffer. }
  54. procedure MD5Buffer (const Buffer; Length : SizeType; var MD5 : TMD5); asmname '_p_md5_buffer';
  55.  
  56. { Computes MD5 message digest for the contents of the file f. }
  57. (*@@iocritical*)procedure MD5File (var f : File; var MD5 : TMD5); asmname '_p_md5_file';
  58.  
  59. { Initializes a MD5 value with zeros. }
  60. procedure MD5Clear (var MD5 : TMD5); asmname '_p_md5_clear';
  61.  
  62. { Compares two MD5 values for equality. }
  63. function MD5Compare (const Value1, Value2 : TMD5) : Boolean; asmname '_p_md5_compare';
  64.  
  65. { Converts an MD5 value to a string. }
  66. function MD5Str ((*@@fjf382 const*) MD5 : TMD5) = s : TString; asmname '_p_md5_str';
  67.  
  68. { Converts a string to an MD5 value. Returns True if successful. }
  69. function MD5Val (const s : String; var MD5 : TMD5) : Boolean; asmname '_p_md5_val';
  70.  
  71. { Composes two MD5 values to a single one. }
  72. function MD5Compose (const Value1, Value2 : TMD5) = Dest : TMD5; asmname '_p_md5_compose';
  73.  
  74. implementation
  75.  
  76. type
  77.   Card32 = Cardinal (32);
  78.   TABCD = array [0 .. 3] of Card32;
  79.  
  80.   { Structure to save state of computation between the single steps. }
  81.   TCtx = record
  82.     ABCD : TABCD;
  83.     Total : Cardinal (64);
  84.     BufLen : Card32;
  85.     Buffer : array [0 .. 127] of Card8
  86.   end;
  87.  
  88. { Initialize structure containing state of computation. (RFC 1321, 3.3: Step 3) }
  89. procedure InitCtx (var Ctx : TCtx);
  90. const InitABCD : TABCD = ($67452301, $efcdab89, $98badcfe, $10325476);
  91. begin
  92.   Ctx.ABCD := InitABCD;
  93.   Ctx.Total := 0;
  94.   Ctx.BufLen := 0
  95. end;
  96.  
  97. { Process Length bytes of Buffer, accumulating context into Ctx.
  98.   It is necessary that Length is a multiple of 64! }
  99. procedure ProcessBlock (const Buffer; Length : SizeType; var Ctx : TCtx);
  100. var
  101.   ABCD, Save : TABCD;
  102.   i : Integer;
  103.   WordsTotal : SizeType = Length div SizeOf (Card32);
  104.   WordsDone : SizeType;
  105.   WordBuffer : array [0 .. WordsTotal - 1] of Card32 absolute Buffer;
  106.   CorrectWords : array [0 .. 15] of Card32;
  107.   n : Card32;
  108. begin
  109.   { First increment the byte count. RFC 1321 specifies the possible length
  110.     of the file up to 2^64 bits. Here we only compute the number of bytes. }
  111.   Inc (Ctx.Total, Length);
  112.   { Process all bytes in the buffer with 64 bytes in each round of the loop. }
  113.   ABCD := Ctx.ABCD;
  114.   WordsDone := 0;
  115.   while WordsDone < WordsTotal do
  116.     begin
  117.       Save := ABCD;
  118.       i := 0;
  119.       { These are the four functions used in the four steps of the MD5 algorithm
  120.         and defined in the RFC 1321. The first function is a little bit optimized
  121.         (as found in Colin Plumbs public domain implementation). }
  122.       {.$define FF(b, c, d) ((b and c) or (not b and d))}
  123.       {$define FF(b, c, d) (d xor (b and (c xor d)))}
  124.       {$define FG(b, c, d) FF (d, b, c)}
  125.       {$define FH(b, c, d) (b xor c xor d)}
  126.       {$define FI(b, c, d) (c xor (b or not d))}
  127.       {$define RotLeft(w, s) w := (w shl s) or (w shr (32 - s))} { cyclic rotation }
  128.       { First round: using the given function, the context and a constant
  129.         the next context is computed. Because the algorithms processing
  130.         unit is a 32-bit word and it is determined to work on words in
  131.         little endian byte order we perhaps have to change the byte order
  132.         before the computation. To reduce the work for the next steps
  133.         we store the swapped words in the array CorrectWords. }
  134.       {$ifdef __WORDS_BIG_ENDIAN__}
  135.       {$define Swap(n)
  136.         n := (n shl 16) or (n shr 16);
  137.         n := ((n and $ff00ff) shl 8) or ((n and $ff00ff00) shr 8);
  138.       }
  139.       {$elif defined (__BYTES_LITTLE_ENDIAN__)}
  140.       {$define Swap(n)}
  141.       {$else}
  142.       {$error Endianness is not defined!}
  143.       {$endif}
  144.       {$define OP1(a, b, c, d, s, T)
  145.         begin
  146.           n := WordBuffer [WordsDone];
  147.           Inc (WordsDone);
  148.           Swap (n);
  149.           CorrectWords [i] := n;
  150.           Inc (i);
  151.           Inc (a, FF (b, c, d) + n + T);
  152.           RotLeft (a, s);
  153.           Inc (a, b)
  154.         end
  155.       }
  156.       {$define A ABCD[0]}
  157.       {$define B ABCD[1]}
  158.       {$define C ABCD[2]}
  159.       {$define D ABCD[3]}
  160.       { Before we start, one word to the strange constants. They are defined
  161.         in RFC 1321 as T[i] = Trunc (4294967296 * abs (sin (i))), i = 1 .. 64 }
  162.       { Round 1. }
  163.       OP1 (A, B, C, D,  7, $d76aa478);
  164.       OP1 (D, A, B, C, 12, $e8c7b756);
  165.       OP1 (C, D, A, B, 17, $242070db);
  166.       OP1 (B, C, D, A, 22, $c1bdceee);
  167.       OP1 (A, B, C, D,  7, $f57c0faf);
  168.       OP1 (D, A, B, C, 12, $4787c62a);
  169.       OP1 (C, D, A, B, 17, $a8304613);
  170.       OP1 (B, C, D, A, 22, $fd469501);
  171.       OP1 (A, B, C, D,  7, $698098d8);
  172.       OP1 (D, A, B, C, 12, $8b44f7af);
  173.       OP1 (C, D, A, B, 17, $ffff5bb1);
  174.       OP1 (B, C, D, A, 22, $895cd7be);
  175.       OP1 (A, B, C, D,  7, $6b901122);
  176.       OP1 (D, A, B, C, 12, $fd987193);
  177.       OP1 (C, D, A, B, 17, $a679438e);
  178.       OP1 (B, C, D, A, 22, $49b40821);
  179.       { For the second to fourth round we have the possibly swapped words
  180.         in CorrectWords. Define a new macro to take an additional first
  181.         argument specifying the function to use. }
  182.       {$define OP(f, a, b, c, d, k, s, T)
  183.         begin
  184.           Inc (a, f (b, c, d) + CorrectWords [k] + T);
  185.           RotLeft (a, s);
  186.           Inc (a, b)
  187.         end
  188.       }
  189.       { Round 2. }
  190.       OP (FG, A, B, C, D,  1,  5, $f61e2562);
  191.       OP (FG, D, A, B, C,  6,  9, $c040b340);
  192.       OP (FG, C, D, A, B, 11, 14, $265e5a51);
  193.       OP (FG, B, C, D, A,  0, 20, $e9b6c7aa);
  194.       OP (FG, A, B, C, D,  5,  5, $d62f105d);
  195.       OP (FG, D, A, B, C, 10,  9, $02441453);
  196.       OP (FG, C, D, A, B, 15, 14, $d8a1e681);
  197.       OP (FG, B, C, D, A,  4, 20, $e7d3fbc8);
  198.       OP (FG, A, B, C, D,  9,  5, $21e1cde6);
  199.       OP (FG, D, A, B, C, 14,  9, $c33707d6);
  200.       OP (FG, C, D, A, B,  3, 14, $f4d50d87);
  201.       OP (FG, B, C, D, A,  8, 20, $455a14ed);
  202.       OP (FG, A, B, C, D, 13,  5, $a9e3e905);
  203.       OP (FG, D, A, B, C,  2,  9, $fcefa3f8);
  204.       OP (FG, C, D, A, B,  7, 14, $676f02d9);
  205.       OP (FG, B, C, D, A, 12, 20, $8d2a4c8a);
  206.       { Round 3. }
  207.       OP (FH, A, B, C, D,  5,  4, $fffa3942);
  208.       OP (FH, D, A, B, C,  8, 11, $8771f681);
  209.       OP (FH, C, D, A, B, 11, 16, $6d9d6122);
  210.       OP (FH, B, C, D, A, 14, 23, $fde5380c);
  211.       OP (FH, A, B, C, D,  1,  4, $a4beea44);
  212.       OP (FH, D, A, B, C,  4, 11, $4bdecfa9);
  213.       OP (FH, C, D, A, B,  7, 16, $f6bb4b60);
  214.       OP (FH, B, C, D, A, 10, 23, $bebfbc70);
  215.       OP (FH, A, B, C, D, 13,  4, $289b7ec6);
  216.       OP (FH, D, A, B, C,  0, 11, $eaa127fa);
  217.       OP (FH, C, D, A, B,  3, 16, $d4ef3085);
  218.       OP (FH, B, C, D, A,  6, 23, $04881d05);
  219.       OP (FH, A, B, C, D,  9,  4, $d9d4d039);
  220.       OP (FH, D, A, B, C, 12, 11, $e6db99e5);
  221.       OP (FH, C, D, A, B, 15, 16, $1fa27cf8);
  222.       OP (FH, B, C, D, A,  2, 23, $c4ac5665);
  223.       { Round 4. }
  224.       OP (FI, A, B, C, D,  0,  6, $f4292244);
  225.       OP (FI, D, A, B, C,  7, 10, $432aff97);
  226.       OP (FI, C, D, A, B, 14, 15, $ab9423a7);
  227.       OP (FI, B, C, D, A,  5, 21, $fc93a039);
  228.       OP (FI, A, B, C, D, 12,  6, $655b59c3);
  229.       OP (FI, D, A, B, C,  3, 10, $8f0ccc92);
  230.       OP (FI, C, D, A, B, 10, 15, $ffeff47d);
  231.       OP (FI, B, C, D, A,  1, 21, $85845dd1);
  232.       OP (FI, A, B, C, D,  8,  6, $6fa87e4f);
  233.       OP (FI, D, A, B, C, 15, 10, $fe2ce6e0);
  234.       OP (FI, C, D, A, B,  6, 15, $a3014314);
  235.       OP (FI, B, C, D, A, 13, 21, $4e0811a1);
  236.       OP (FI, A, B, C, D,  4,  6, $f7537e82);
  237.       OP (FI, D, A, B, C, 11, 10, $bd3af235);
  238.       OP (FI, C, D, A, B,  2, 15, $2ad7d2bb);
  239.       OP (FI, B, C, D, A,  9, 21, $eb86d391);
  240.       { Add the starting values of the context. }
  241.       for i := 0 to 3 do
  242.         Inc (ABCD [i], Save [i])
  243.     end;
  244.   Ctx.ABCD := ABCD
  245. end;
  246.  
  247. { Starting with the result of former calls to this function (or
  248.   InitCtx) update the context for the next Length bytes in Buffer.
  249.   It is not required that Length is a multiple of 64. }
  250. procedure ProcessBytes (const aBuffer; Length : SizeType; var Ctx : TCtx);
  251. var
  252.   BytesDone, Block, LeftOver : SizeType;
  253.   ByteBuffer : array [0 .. Length - 1] of Card8 absolute aBuffer;
  254. begin
  255.   BytesDone := 0;
  256.   { When we already have some bits in our internal buffer concatenate both inputs first. }
  257.   with Ctx do
  258.     if BufLen <> 0 then
  259.       begin
  260.         LeftOver := BufLen;
  261.         BytesDone := Min (128 - LeftOver, Length);
  262.         Move (ByteBuffer, Buffer [LeftOver], BytesDone);
  263.         Inc (BufLen, BytesDone);
  264.         if BufLen > 64 then
  265.           begin
  266.             Block := BufLen div 64 * 64;
  267.             ProcessBlock (Buffer, Block, Ctx);
  268.             BufLen := BufLen mod 64;
  269.             Move (Buffer [Block], Buffer, BufLen) { source and destination cannot overlap }
  270.           end;
  271.         Dec (Length, BytesDone)
  272.       end;
  273.   { Process available complete blocks. }
  274.   if Length > 64 then
  275.     begin
  276.       Block := Length div 64 * 64;
  277.       ProcessBlock (ByteBuffer [BytesDone], Block, Ctx);
  278.       Inc (BytesDone, Block);
  279.       Dec (Length, Block)
  280.     end;
  281.   { Move remaining bytes into internal buffer. }
  282.   if Length > 0 then
  283.     begin
  284.       Move (ByteBuffer [BytesDone], Ctx.Buffer, Length);
  285.       Ctx.BufLen := Length
  286.     end
  287. end;
  288.  
  289. { Process the remaining bytes in the buffer and put result from Ctx into MD5. }
  290. procedure FinishCtx (var Ctx : TCtx; var MD5 : TMD5);
  291. var i, j, Pad : Integer;
  292. begin
  293.   with Ctx do
  294.     begin
  295.       Pad := 56 - BufLen;
  296.       if Pad <= 0 then Inc (Pad, 64);
  297.       if Pad > 0 then
  298.         begin
  299.           Buffer [BufLen] := $80;
  300.           FillChar (Buffer [BufLen + 1], Pad - 1, 0)
  301.         end;
  302.       Inc (Total, BufLen);
  303.       { Put the 64-bit total length in *bits* at the end of the buffer. }
  304.       for j := 0 to 7 do
  305.         Buffer [BufLen + Pad + j] := ((Total * BitSizeOf (Card8)) shr (8 * j)) and $ff;
  306.       ProcessBlock (Buffer, BufLen + Pad + 8, Ctx);
  307.       for i := 0 to 3 do
  308.         for j := 0 to 3 do
  309.           MD5 [4 * i + j + 1] := (Ctx.ABCD [i] shr (8 * j)) and $ff
  310.     end
  311. end;
  312.  
  313. procedure MD5Buffer (const Buffer; Length : SizeType; var MD5 : TMD5);
  314. var Ctx : TCtx;
  315. begin
  316.   InitCtx (Ctx);
  317.   ProcessBytes (Buffer, Length, Ctx);
  318.   FinishCtx (Ctx, MD5)
  319. end;
  320.  
  321. procedure MD5File (var f : File; var MD5 : TMD5);
  322. var
  323.   Ctx : TCtx;
  324.   Buffer : array [1 .. 4096] of Card8;
  325.   BytesRead : (*@@fjf252*)(*SizeType*) Word;
  326. begin
  327.   InitCtx (Ctx);
  328.   Reset (f, 1);
  329.   repeat
  330.     BlockRead (f, Buffer, SizeOf (Buffer), BytesRead);
  331.     if InOutRes <> 0 then Exit;
  332.     ProcessBytes (Buffer, BytesRead, Ctx)
  333.   until EOF (f);
  334.   FinishCtx (Ctx, MD5)
  335. end;
  336.  
  337. procedure MD5Clear (var MD5 : TMD5);
  338. var i : Integer;
  339. begin
  340.   for i := Low (MD5) to High (MD5) do MD5 [i] := 0
  341. end;
  342.  
  343. function MD5Compare (const Value1, Value2 : TMD5) : Boolean;
  344. var i : Integer;
  345. begin
  346.   MD5Compare := False;
  347.   for i := Low (Value1) to High (Value1) do
  348.     if Value1 [i] <> Value2 [i] then Exit;
  349.   MD5Compare := True
  350. end;
  351.  
  352. function MD5Str ((*@@fjf382 const*) MD5 : TMD5) = s : TString;
  353. const HexDigits : array [0 .. $f] of Char = '0123456789abcdef';
  354. var i : Integer;
  355. begin
  356.   s := '';
  357.   for i := Low (MD5) to High (MD5) do
  358.     s := s + HexDigits [MD5 [i] div $10] + HexDigits [MD5 [i] mod $10]
  359. end;
  360.  
  361. function MD5Val (const s : String; var MD5 : TMD5) : Boolean;
  362. var i, d1, d2 : Integer;
  363.  
  364.   function Char2Digit (ch : Char) : Integer;
  365.   begin
  366.     case ch of
  367.       '0' .. '9': Char2Digit := Ord (ch) - Ord ('0');
  368.       'A' .. 'Z': Char2Digit := Ord (ch) - Ord ('A') + $a;
  369.       'a' .. 'z': Char2Digit := Ord (ch) - Ord ('a') + $a;
  370.       else        Char2Digit := -1
  371.     end
  372.   end;
  373.  
  374. begin
  375.   MD5Val := False;
  376.   if Length (s) <> 2 * (High (MD5) - Low (MD5) + 1) then Exit;
  377.   for i := Low (MD5) to High (MD5) do
  378.     begin
  379.       d1 := Char2Digit (s [2 * (i - Low (MD5)) + 1]);
  380.       d2 := Char2Digit (s [2 * (i - Low (MD5)) + 2]);
  381.       if (d1 < 0) or (d2 < 0) then Exit;
  382.       MD5 [i] := $10 * d1 + d2
  383.     end;
  384.   MD5Val := True
  385. end;
  386.  
  387. (*@@ I'm not sure if xor'ing MD5 values is really safe (concerning
  388.      properties of non-reproducibility). I suppose it is, but if
  389.      not, this operation can be exchanged. One alternative would be
  390.      MD5'ing again both MD5 values put in a row. *)
  391. function MD5Compose (const Value1, Value2 : TMD5) = Dest : TMD5;
  392. var i : Integer;
  393. begin
  394.   for i := Low (Dest) to High (Dest) do
  395.     Dest [i] := Value1 [i] xor Value2 [i]
  396. end;
  397.  
  398. end.
  399.